The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/MSGREAD.PAS

Pascal/Delphi Source File | 1988-09-14 | 23.7 KB | 702 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  5-27-88 8:11 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit MsgRead;

Interface

Uses
  TPCrt, TPDOS, Globals, TAccess, Core1, Core2,
  MsgMove, MsgEntr, MsgMisc, EditUsr1, EditUsr2;


procedure mesg_header_list(loc             : Integer;
                           var first_line,
                           last_line       : Integer;
                           var Fr_fn       : FirstName;
                           var Fr_ln       : LastName);

procedure mesg_quick_scan;

procedure mesg_summary;

procedure mesg_read;


  {==========================================================================}


Implementation


  procedure SysopCmds(var update : Boolean);

  var
    ch, drive       : Char;
    work            : DosFileName;
    This            : AreaPtr;
    temp_name       : DosFileName;

  begin
    repeat
      WriteLn(Com);
      st := prompt('Sysop Message command <D><H><I><M><N><P><R><Q><?>', 80, 'ES?');
      if Length(st) = 1 then
        ch := st[1]
      else
        ch := '?';
      case ch of
        'D' :
          begin
            summ_rec.status := deleted;
            summ_rec.num_prev := 0;
          end;
        'H' :
          summ_rec.status := restricted;
        'I' :
          summ_rec.status := private;
        'M' :
          begin
            abort := False;
            repeat
              This := AreaBase;
              work := prompt('Message Area ', 12, 'ES?M');
              if work = '?' then
                begin
                  WriteLn(Com, 'Available Message Areas:');
                  WriteLn(Com);
                  while (not brk) and (This <> nil) do
                    begin
                      if This^.AreaName[1] <> '-' then
                        WriteLn(Com, This^.AreaName)
                      else
                        begin
                          temp_name := This^.AreaName;
                          Delete(temp_name, 1, 1);
                          WriteLn(Com, temp_name)
                        end;
                      This := This^.next;
                    end;
                end;
              This := AreaBase;   {set up to find name match}
              while (This <> nil) and (This^.AreaName <> work) and
              (Pos(work, This^.AreaName) <> 2) do
                This := This^.next;
            until (work = This^.AreaName) or (brk) or (not Online)
            or (Pos(work, This^.AreaName) = 2);

            if (This^.AreaName[1] = '-') or (This^.AreaName = 'NETMAIL') then
              begin
                drive := DefaultDrive;
                work := drive+':\TEMP.MSG';
                record_msg(work);
                make_fido_message(This^.AreaName, work, summ_rec.user_from,
                  summ_rec.user_to, summ_rec.subject,
                  False, '', 0, 0, False);
              end
            else
              summ_rec.Area := This^.Area;
          end;
        'N' :
          begin
            if summ_rec.num_prev = 0 then
              summ_rec.num_prev := 255
            else
              summ_rec.num_prev := 0;
            if summ_rec.num_prev = 255 then
              Write(Com, 'NOT ');
            WriteLn(Com, 'subject to purge.');
          end;
        'P' :
          summ_rec.status := public;
        'R' :
          summ_rec.status := Seen
      else
        WriteLn(Com, '<D>elete, <H>ide, pr<I>vate, <M>ove, <N>o Purge, <P>ublic, <R>ead, <Q>uit')
      end
    until (not Online) or (ch in ['D', 'H', 'I', 'M', 'N', 'P', 'R', 'Q']);
    update := True;
  end;                            {SysopCmds}



  function mesg_start(pr : StrPr)     : Integer;
    { Get starting message number from user }

  var
    i, last         : Integer;

  begin
    repeat
      WriteLn(Com);
      last := user_rec.lasthi;
      i := strint(prompt(pr+' (last mesg you read is '+intstr(last, 1)+') '+' ['+intstr(msg_lo,
        1)+'-'+intstr(msg_hi, 1)+']?', 5, 'E'));
      if ((i < msg_lo) or (i > msg_hi)) and (i <> 0) then
        WriteLn(Com, 'Invalid message number, try again.');
    until ((i >= msg_lo) and (i <= msg_hi)) or (i = 0) or (not Online);
    mesg_start := i
  end;



  procedure mesg_header_list(loc             : Integer;
                             var first_line,
                             last_line       : Integer;
                             var Fr_fn       : FirstName;
                             var Fr_ln       : LastName);
    { Display message header }

  var
    to_fn           : FirstName;
    to_ln           : LastName;
    Str             : StrTAD;
    temp_user_rec   : user_list;
    This            : AreaPtr;
    from_temp,
    to_temp         : Str36;

  begin
    Write(Com, yellow);
    Seek(summ_file, loc);
    Read(summ_file, summ_rec);
    with summ_rec do
      begin
        if user_to = 0 then
          begin
            to_fn := 'ALL';
            to_ln := ''
          end
        else if user_to = user_loc then
          begin
            to_fn := user_rec.fn;
            to_ln := user_rec.ln
          end
        else
          begin
            if user_to <> -1 then
              begin
                GetRec(DatF, user_to, temp_user_rec);
                to_fn := temp_user_rec.fn;
                to_ln := temp_user_rec.ln;
              end
            else
              begin
                to_fn := 'Deleted';
                to_ln := 'User';
              end;
          end;
        if user_from = user_loc then
          begin
            Fr_fn := user_rec.fn;
            Fr_ln := user_rec.ln
          end
        else
          begin
            if user_from <> -1 then
              begin
                GetRec(DatF, user_from, temp_user_rec);
                Fr_fn := temp_user_rec.fn;
                Fr_ln := temp_user_rec.ln;
              end
            else
              begin
                Fr_fn := 'Deleted';
                Fr_ln := 'User';
              end;
          end;
        Str := FormTAD(date);
        This := AreaBase;
        while (This <> nil) and (This^.Area <> Area) do
          This := This^.next;
        WriteLn(Com);
        if num_prev = 255 then
          Write(Com, '<P>');
        case status of
          deleted :
            Write(Com, 'Deleted');
          Seen :
            Write(Com, 'Read');
          private :
            Write(Com, 'Private');
          public :
            Write(Com, 'Public');
          restricted :
            Write(Com, 'Restricted');
        end;
        WriteLn(Com, ' message # ', num, '    ', This^.AreaName, ' AREA ', '   Entered ', Str);
        from_temp := Fr_fn+' '+Fr_ln;
        {$V-}
        caps_to_mixed(from_temp);
        to_temp := to_fn+' '+to_ln;
        caps_to_mixed(to_temp) {$V+} ;
        WriteLn(Com, white, 'From: ', cyan, from_temp);
        WriteLn(Com, white, '  To: ', cyan, to_temp);
        WriteLn(Com, white, '  Re: ', cyan, subject, yellow);
        if audit_on then
          begin
            SetSect(AudName);
            WriteLn(AuditFile);
            if num_prev = 255 then
              Write(AuditFile, '<P>');
            case status of
              deleted :
                Write(AuditFile, 'Deleted');
              Seen :
                Write(AuditFile, 'Read');
              private :
                Write(AuditFile, 'Private');
              public :
                Write(AuditFile, 'Public');
              restricted :
                Write(AuditFile, 'Restricted');
            end;
            WriteLn(AuditFile, ' message # ', num, ' entered ', Str);
            WriteLn(AuditFile, 'From: ', Fr_fn, ' ', Fr_ln);
            WriteLn(AuditFile, '  To: ', to_fn, ' ', to_ln);
            WriteLn(AuditFile, '  Re: ', subject);
            SetSect(HomName);
          end;
        first_line := st_rec;
        last_line := size
      end

  end;                            {message header list}



  procedure mesg_quick_scan;
    { Print abbreviated summary of messages }

  var
    private         : Boolean;
    sep             : Char;
    num,
    line_count      : Integer;

  begin
    line_count := 0;
    private := False;
    num := mesg_start('Start');
    if num <> 0 then
      begin
        MesgCurr := MesgBase;
        while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
          MesgCurr := MesgCurr^.next;
        WriteLn(Com);
        abort := False;
        while (not brk) and (MesgCurr <> nil) do
          begin
            if (MesgCurr^.TypMsg = 1) or (MesgCurr^.TypMsg = 2) then
              begin
                private := True;
                sep := '*'
              end
            else
              sep := ':';
            Seek(summ_file, MesgCurr^.SummLoc);
            Read(summ_file, summ_rec);
            WriteLn(Com, MesgCurr^.MesgNo, sep, ' ', summ_rec.subject);
            MesgCurr := MesgCurr^.next;
            if user_rec.lines <> 99 then
              begin
                Inc(line_count);
                if line_count mod user_rec.lines = 0 then
                  pause
              end
          end;
        if private then
          begin
            WriteLn(Com);
            WriteLn(Com, '"*" marks messages to or from you.')
          end
      end;
  end;



  procedure mesg_summary;
    { Message summary }

  var
    num,
    first_line,
    last_line,
    line_count      : Integer;
    Fr_fn           : FirstName;
    Fr_ln           : LastName;

  begin
    line_count := 0;
    abort := False;
    num := mesg_start('Start');
    if num <> 0 then
      begin
        MesgCurr := MesgBase;
        while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
          MesgCurr := MesgCurr^.next;
        while (not brk) and (MesgCurr <> nil) do
          begin
            mesg_header_list(MesgCurr^.SummLoc, first_line, last_line, Fr_fn, Fr_ln);
            MesgCurr := MesgCurr^.next;
            if user_rec.lines <> 99 then
              begin
                Inc(line_count);
                if line_count mod (user_rec.lines div 5) = 0 then
                  pause
              end
          end
      end;
  end;



  procedure mesg_read;
    { Read message }

  var
    This            : MesgPtr;
    ch, option      : Char;
    pr_str,
    Dirspec         : StrPr;
    RefDrv          : Str3;
    Fr_fn           : FirstName;
    Fr_ln           : LastName;
    update, skip,
    backup, OK      : Boolean;
    i, num,
    first_line,
    last_line,
    line_count,
    strt            : Integer;
    RefFile,
    RefSect         : DosFileName;
    this_type       : Byte;

  begin
    OK := True;
    nonstop := False;
    MesgCurr := MesgBase;
    num := 0;
    abort := False;
    repeat
      WriteLn(Com);
      st := prompt('Read Search Option <A><F><T><N><S><Q> ', 80, 'ES?M');
      if Length(st) = 1 then
        option := st[1]
      else
        option := '?';
      if option = '?' then
        begin
          WriteLn(Com, '<A>ll, <F>rom you, <T>o you <N>umeric, <S>ince your last call, <Q>uit')
          ;
          mult_cmds := False;
          Cmd_Queue := '';
        end;
    until (not Online) or (option in ['A', 'F', 'T', 'N', 'S', 'Q']);
    case option of
      'A' :
        if MesgBase <> nil then
          num := MesgBase^.MesgNo;
      'N' :
        begin
          num := mesg_start('Start'); {get starting number}
          if num = 0 then OK := False;
        end;
      'F' :
        begin
          if msg_aut = 0 then
            begin
              OK := False;
              WriteLn(Com, 'No Messages From You.');
            end;
        end;
      'T' :
        begin
          if msg_ind = 0 then
            begin
              OK := False;
              WriteLn(Com, 'No Messages for you.');
            end;
        end;
      'S' :
        num := Succ(user_rec.lasthi);
      'Q' :
        OK := False;
    end;
    if ((num > 0) and (OK)) then
      while (MesgCurr <> nil) and (MesgCurr^.MesgNo < num) do
        MesgCurr := MesgCurr^.next;

    while (not brk) and (MesgCurr <> nil) and OK and Online do
      begin
        backup := False;
        skip := False;
        update := False;
        if option = 'F' then
          while (MesgCurr <> nil) and (MesgCurr^.TypMsg <> 2) do
            MesgCurr := MesgCurr^.next;
        if option = 'T' then
          while (MesgCurr <> nil) and (MesgCurr^.TypMsg <> 1) do
            MesgCurr := MesgCurr^.next;
        if (MesgCurr <> nil) then
          begin
            if MesgCurr^.MesgNo > temp_hi_lmr then
              temp_hi_lmr := MesgCurr^.MesgNo;
            mesg_header_list(MesgCurr^.SummLoc, first_line, last_line, Fr_fn, Fr_ln);
            line_count := 4;
            if (not nonstop) then
              begin
                repeat
                  repeat
                    WriteLn(Com);
                    pr_str := white+intstr(time_left, 1)+'-'+yellow+'Read <Y><N><C><Q><P><R>';
                    if user_rec.access >= 250 then
                      pr_str := pr_str+'<X><E><V><S>';
                    st := prompt(pr_str+cyan, 1, 'ESA?M');
                    if Length(st) = 1 then
                      ch := st[1]
                    else
                      ch := '?';
                    if (user_rec.access < 250) and ((ch = 'X') or (ch = 'E')
                      or (ch = 'S') or (ch = 'V'))
                    then
                      ch := '?';
                    if ch = '?' then
                      begin
                        WriteLn(Com,
                          '<Y>es, <N>o, <C>ontinuous, <Q>uit, <P>revious, <R>eply');
                        if user_rec.access >= 250 then
                          WriteLn(Com,
                            '<X> Sysop Commands, <E>dit or <V>alidate caller, <S>ave to disk');
                        mult_cmds := False;
                        Cmd_Queue := '';
                      end;
                  until (not Online) or
                  (ch in ['Y', 'N', 'C', 'Q', 'P', 'R', 'X', 'E', 'V', 'S']);
                  case ch of
                    'Q' :
                      OK := False;
                    'C' :
                      nonstop := True;
                    'N' :
                      skip := True;
                    'P' :
                      backup := True;
                    'R' :
                      begin
                        skip := True;
                        if user_rec.access >= val_acc then
                          mesg_enter('A')
                        else
                          WriteLn(Com, 'Replys not accepted until validation.');
                      end;
                    'S' :
                      if user_rec.access >= 250 then
                        begin
                          record_msg('');
                          skip := True;
                        end;
                    'X' :
                      if user_rec.access >= 250 then
                        begin
                          SysopCmds(update);
                          skip := True;
                        end
                      else
                        OK := False;
                    'E' :
                      begin
                        if user_rec.access >= 250 then
                          edit_user(Fr_fn, Fr_ln, 0)
                        else
                          OK := False;
                        mesg_header_list(MesgCurr^.SummLoc, first_line,
                          last_line, Fr_fn, Fr_ln);
                      end;
                    'V' :
                      begin
                        if user_rec.access >= 250 then
                          Validate_user(Fr_fn, Fr_ln)
                        else
                          OK := False;
                        mesg_header_list(MesgCurr^.SummLoc, first_line,
                          last_line, Fr_fn, Fr_ln);
                      end;
                  end;
                until ((ch <> 'E') and (ch <> 'V')) or (not Online);
              end;                {not nonstop}
            WriteLn(Com);
            if (not skip) and (OK) and (not backup) then
              begin
                check_time;
                i := 1;
                Seek(mesg_file, first_line);
                while (not brk) and (i <= last_line) and Online do
                  begin
                    Read(mesg_file, mesg_rec);
                    strt := Pos('//', mesg_rec); { format: //section/filename/ }
                    if (strt > 0) and (summ_rec.num_next > 0) then
                      begin
                        RefSect := '';
                        RefFile := '';
                        strt := strt+2; {offset}
                        while (mesg_rec[strt] <> '/') and (strt <= Length(mesg_rec)) do
                          begin
                            RefSect := RefSect+Upcase(mesg_rec[strt]);
                            Inc(strt);
                          end;
                        Inc(strt); {offset again}
                        while (mesg_rec[strt] <> '/') and (strt <= Length(mesg_rec)) do
                          begin
                            RefFile := RefFile+Upcase(mesg_rec[strt]);
                            Inc(strt);
                          end;
                        if (RefSect <> '') and (RefFile <> '') then
                          begin
                            FindSect(RefSect, RefDrv, OK);
                            if OK then
                              begin
                                if RefSect = 'SYSTEM' then
                                  Dirspec := HomName
                                else
                                  begin
                                    Dirspec := RefDrv;
                                    if (Length(HomName) > 3) and (Dirspec = HomDrv
                                      ) then
                                      begin
                                        Dirspec := Dirspec+Copy(HomName, 4,
                                          Length(HomName));
                                        Dirspec := Dirspec+'\';
                                      end;
                                    Dirspec := Dirspec+RefSect;
                                  end;
                                list_file(RefFile, Dirspec);
                                line_count := 1;
                              end
                            else
                              OK := True; {preset for next msg. }
                          end;
                      end
                    else
                      WriteLn(Com, mesg_rec); {type message lines}
                    Inc(i);
                    if (user_rec.lines <> 99) and (not nonstop) then
                      begin
                        Inc(line_count);
                        if line_count mod user_rec.lines = 0 then
                          pause;
                      end;
                  end;            {print msg text}
                update := (summ_rec.user_to = user_loc) and ((summ_rec.status = private) or
                  (summ_rec.status = public));
                if update then
                  summ_rec.status := Seen;
                if ((summ_rec.user_from = user_loc) or (summ_rec.user_to = user_loc)) and (
                  not nonstop) and
                (not backup) and (summ_rec.status <> deleted) then
                  begin
                    i := 0;
                    WriteLn(Com);
                    pr_str := 'DELETE this message';
                    if (summ_rec.user_to = user_loc) then
                      if ask(white+'Reply to Message'+cyan, 'N') then
                        begin
                          i := MesgCurr^.SummLoc;
                          mesg_enter('A');
                          pr_str := 'DELETE original message';
                        end;
                    WriteLn(Com);
                    if ask(white+pr_str+cyan, 'N') then
                      begin
                        if ask(white+'Are you sure'+cyan, 'N') then
                          begin
                            if i > 0 then
                              begin
                                Seek(summ_file, i);
                                Read(summ_file, summ_rec);
                              end;
                            summ_rec.status := deleted;
                            update := True;
                            MesgCurr := MesgCurr^.next;
                            WriteLn(Com, 'Message deleted.');
                          end
                        else
                          begin
                            WriteLn(Com, 'Message retained.');
                            MesgCurr := MesgCurr^.next;
                          end;
                      end
                    else
                      begin
                        WriteLn(Com, 'Message retained.');
                        MesgCurr := MesgCurr^.next
                      end;
                  end
                else
                  MesgCurr := MesgCurr^.next;
              end;                {skip, backup & OK}
            if update then
              begin
                Seek(summ_file, Pred(FilePos(summ_file)));
                Write(summ_file, summ_rec)
              end;
            if (skip) and (Online) then
              MesgCurr := MesgCurr^.next;
            WriteLn(Com);
            if (backup) then
              begin
                backup := False;
                if (MesgCurr <> MesgBase) then
                  begin
                    This := MesgCurr;
                    MesgCurr := MesgBase; {find previous record}
                    MesgPrev := MesgBase;
                    if option in ['F', 'T'] then
                      begin
                        if option = 'F' then
                          this_type := 2
                        else
                          this_type := 1;
                        while (MesgCurr <> nil) and (MesgCurr^.Next <> This) do
                          begin
                            if MesgCurr^.TypMsg = this_type then
                              MesgPrev := MesgCurr;
                            MesgCurr := MesgCurr^.next;
                          end;
                        if MesgCurr^.TypMsg = this_type then
                          MesgPrev := MesgCurr;
                        MesgCurr := MesgPrev;
                      end
                    else
                      begin
                        while MesgCurr^.next <> This do
                          MesgCurr := MesgCurr^.next;
                      end;
                  end;            {backup}
              end;


          end;                    {if mesgcurr<>nil}
      end;                        {print msg and header}
    if (not OK) then
      begin
        mult_cmds := False;
        Cmd_Queue := '';
      end;
    nonstop := False;
  end;                            {read messages}


end.                              { of MSGREAD.PAS}